home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Gold Medal Software 2
/
Gold Medal Software Volume 2 (Gold Medal) (1994).iso
/
print
/
wsfont.arj
/
WSFONTS.FRM
< prev
next >
Wrap
Text File
|
1993-10-04
|
10KB
|
362 lines
VERSION 2.00
Begin Form Form1
BackColor = &H00C0C0C0&
BorderStyle = 3 'Fixed Double
Caption = "Font Manager"
FillColor = &H00C0C0C0&
FillStyle = 5 'Downward Diagonal
ForeColor = &H00000000&
Height = 4470
Icon = WSFONTS.FRX:0000
Left = 2160
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 3780
ScaleWidth = 7890
Top = 1725
Width = 8010
Begin CommonDialog CMDialog1
Left = 3600
Top = 120
End
Begin CommandButton Command1
BackColor = &H00FF0000&
Caption = "τ"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "Wingdings"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 375
Index = 1
Left = 3480
TabIndex = 3
Top = 1800
Width = 855
End
Begin CommandButton Command1
BackColor = &H00FF0000&
Caption = "Φ"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "Wingdings"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 375
Index = 0
Left = 3480
TabIndex = 2
Top = 1080
Width = 855
End
Begin ListBox List2
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 2760
Left = 4440
MultiSelect = 2 'Extended
Sorted = -1 'True
TabIndex = 5
Top = 480
Width = 3300
End
Begin ListBox List1
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 2760
Left = 120
MultiSelect = 2 'Extended
Sorted = -1 'True
TabIndex = 1
Top = 480
Width = 3300
End
Begin Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "label2"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 195
Left = 120
TabIndex = 6
Top = 3555
Width = 420
End
Begin Line Line2
BorderColor = &H00808080&
X1 = 1560
X2 = 3840
Y1 = 3480
Y2 = 3480
End
Begin Line Line1
BorderColor = &H00FFFFFF&
X1 = 2520
X2 = 6240
Y1 = 3480
Y2 = 3480
End
Begin Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "&Reserve Fonts:"
ForeColor = &H00000000&
Height = 195
Index = 1
Left = 4440
TabIndex = 4
Top = 240
Width = 1305
End
Begin Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "&Installed Fonts:"
ForeColor = &H00000000&
Height = 195
Index = 0
Left = 120
TabIndex = 0
Top = 225
Width = 1320
End
Begin Menu fMenu
Caption = "&File"
Begin Menu fItem
Caption = "P&rint Setup..."
Index = 0
End
Begin Menu fItem
Caption = "-"
Index = 1
End
Begin Menu fItem
Caption = "E&xit"
Index = 2
End
End
End
Option Explicit
Option Compare Text
DefInt A-Z
Dim bf$(22)
Sub BuildBasics ()
bf$(0) = "Arial (TrueType)"
bf$(1) = "Arial Bold (TrueType)"
bf$(2) = "Arial Bold Italic (TrueType)"
bf$(3) = "Arial Italic (TrueType)"
bf$(4) = "Courier New (TrueType)"
bf$(5) = "Courier New Bold (TrueType)"
bf$(6) = "Courier New Bold Italic (TrueType)"
bf$(7) = "Courier New Italic (TrueType)"
bf$(8) = "Times New Roman (TrueType)"
bf$(9) = "Times New Roman Bold (TrueType)"
bf$(10) = "Times New Roman Bold Italic (TrueType)"
bf$(11) = "Times New Roman Italic (TrueType)"
bf$(12) = "Wingdings (TrueType)"
bf$(13) = "Symbol (TrueType)"
bf$(14) = "System"
bf$(15) = "Modern (Plotter)"
bf$(16) = "Roman (Plotter)"
bf$(17) = "Script (Plotter)"
bf$(18) = "Terminal"
bf$(19) = "Symbol 8"
bf$(20) = "MS Sans Serif"
bf$(21) = "MS Serif"
bf$(22) = "Small ("
End Sub
Sub Callback1_EnumFonts (lpLogFont As Long, lpTextMetrics As Long, nFontTYpe As Integer, lpData As Long, Retval As Integer)
Debug.Print lpLogFont, lpTextMetrics, nFontTYpe, lpData, Retval
End Sub
Function CheckBasics% (fName$)
Dim X%
CheckBasics% = False
For X% = 0 To 19
If fName$ = bf$(X%) Then CheckBasics% = True: Exit Function
' If fName$ + " (TrueType)" = bf$(X%) Then CheckBasics% = True: Exit Function
Next
For X% = 20 To 22
If InStr(fName$, bf$(X%)) Then CheckBasics% = True: Exit Function
Next
End Function
Sub CheckReserveListCount ()
If List2.ListCount > 0 Then
Command1(1).Enabled = True
Else
Command1(1).Enabled = False
End If
End Sub
Sub Command1_Click (Index As Integer)
Command1(0).Enabled = False
Command1(1).Enabled = False
Dim y%, Z%, F$, fc%
Screen.MousePointer = 11
Select Case Index
Case 0 'move to wsfonts
For y% = List1.ListCount - 1 To 0 Step -1
MoveBasic% = True
If List1.Selected(y%) Then
F$ = List1.List(y%)
Z% = CheckBasics%(F$)
If Z% = True Then
TestFont$ = F$
Screen.MousePointer = 0
ConfirmScreen.Show 1
Screen.MousePointer = 11
End If
If MoveBasic% = True Then
Label2 = "Deactivating " + F$
Label2.Refresh
If UninStall%(F$) = True Then
List2.AddItem F$
List1.RemoveItem y%
End If
End If
End If
Next
Case 1 'install
For y% = List2.ListCount - 1 To 0 Step -1
If List2.Selected(y%) Then
F$ = List2.List(y%)
Label2 = "Activating " + F$
Label2.Refresh
If Install%(F$) = True Then
List1.AddItem F$
List2.RemoveItem y%
End If
End If
Next
End Select
BroadcastIniChange
CheckReserveListCount
Label2 = ""
Screen.MousePointer = 0
Command1(0).Enabled = True
Command1(1).Enabled = True
End Sub
Sub fItem_Click (Index As Integer)
Select Case Index
Case 0
CMDialog1.Flags = &H40&
CMDialog1.PrinterDefault = True
CMDialog1.CancelError = True
On Error Resume Next
CMDialog1.Action = 5
If Err = 32755 Then Exit Sub
On Error GoTo 0
Case 1
Case 2
Unload Me
End Select
End Sub
Sub Form_Load ()
Label2 = ""
CRLF$ = Chr$(13) + Chr$(10)
Screen.MousePointer = 11
Show
Refresh
BuildBasics
Dim X%, Temp$, Z%
'load installed fonts from Win.INI
Z% = 1
Temp$ = ListWinIniEntries$("Fonts")
X% = InStr(Temp$, Chr$(0))
Do While X%
If X% = 1 Then Exit Do
List1.AddItem Mid$(Temp$, Z%, X%)
Z% = X% + 1
X% = InStr(Z%, Temp$, Chr$(0))
Loop
'insert load reserve fonts code here
Z% = 1
Temp$ = ListPrivateIniEntries$("Fonts", "WSFONTS.INI")
X% = InStr(Temp$, Chr$(0))
Do While X%
If X% = 1 Then Exit Do
List2.AddItem Mid$(Temp$, Z%, X%)
Z% = X% + 1
X% = InStr(Z%, Temp$, Chr$(0))
Loop
CheckReserveListCount
Screen.MousePointer = 0
End Sub
Sub Form_Paint ()
Line1.X1 = 0
Line1.X2 = Width
Line2.X1 = 0
Line2.X2 = Width
Line2.Y1 = Line1.Y1 + 15
Line2.Y2 = Line1.Y2 + 15
End Sub
Sub List1_Click ()
Set ActiveC = List1
UpdateForm
End Sub
Sub List1_DblClick ()
UpdateForm
End Sub
Sub List2_Click ()
Set ActiveC = List2
UpdateForm
End Sub
Sub List2_DblClick ()
UpdateForm
End Sub
Sub List2_GotFocus ()
List1.ListIndex = -1
End Sub
Sub UpdateForm ()
Select Case ActiveC.SelCount
Case 0
Label2 = ""
Case 1
Label2 = ActiveC
Case Else
Label2 = ActiveC.SelCount & " items selected"
End Select
Dim Test$, fFamily$, fName$, fType$, X%, y%
TestFont$ = ActiveC.List(ActiveC.ListIndex)
If ActiveC = Form1.List2 Then
Test$ = GetPrivINI$("fonts", TestFont$, "uh-oh", "WSFONTS.INI")
Else
Test$ = GetWinINI$("fonts", TestFont$, "uh-oh")
End If
End Sub